home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / macros.lisp < prev    next >
Encoding:
Text File  |  1991-11-09  |  13.8 KB  |  448 lines
  1. ;;; -*- Package: SPARC -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: macros.lisp,v 1.4 91/11/09 02:38:18 wlott Exp $
  11. ;;;
  12. ;;; This file contains various useful macros for generating SPARC code.
  13. ;;;
  14. ;;; Written by William Lott.
  15. ;;; 
  16.  
  17. (in-package "SPARC")
  18.  
  19.  
  20. ;;; Instruction-like macros.
  21.  
  22. (defmacro move (dst src)
  23.   "Move SRC into DST unless they are location=."
  24.   (once-only ((n-dst dst)
  25.           (n-src src))
  26.     `(unless (location= ,n-dst ,n-src)
  27.        (inst move ,n-dst ,n-src))))
  28.  
  29. (macrolet
  30.     ((frob (op inst shift)
  31.        `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
  32.       `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
  33.   (frob loadw ld word-shift)
  34.   (frob storew st word-shift))
  35.  
  36. (defmacro load-symbol (reg symbol)
  37.   `(inst add ,reg null-tn (static-symbol-offset ,symbol)))
  38.  
  39. (macrolet
  40.     ((frob (slot)
  41.        (let ((loader (intern (concatenate 'simple-string
  42.                       "LOAD-SYMBOL-"
  43.                       (string slot))))
  44.          (storer (intern (concatenate 'simple-string
  45.                       "STORE-SYMBOL-"
  46.                       (string slot))))
  47.          (offset (intern (concatenate 'simple-string
  48.                       "SYMBOL-"
  49.                       (string slot)
  50.                       "-SLOT")
  51.                  (find-package "VM"))))
  52.      `(progn
  53.         (defmacro ,loader (reg symbol)
  54.           `(inst ld ,reg null-tn
  55.              (+ (static-symbol-offset ',symbol)
  56.             (ash ,',offset word-shift)
  57.             (- other-pointer-type))))
  58.         (defmacro ,storer (reg symbol)
  59.           `(inst st ,reg null-tn
  60.              (+ (static-symbol-offset ',symbol)
  61.             (ash ,',offset word-shift)
  62.             (- other-pointer-type))))))))
  63.   (frob value)
  64.   (frob function))
  65.  
  66. (defmacro load-type (target source &optional (offset 0))
  67.   "Loads the type bits of a pointer into target independent of
  68.   byte-ordering issues."
  69.   (once-only ((n-target target)
  70.           (n-source source)
  71.           (n-offset offset))
  72.     (ecase (backend-byte-order *target-backend*)
  73.       (:little-endian
  74.        `(inst ldub ,n-target ,n-source ,n-offset))
  75.       (:big-endian
  76.        `(inst ldub ,n-target ,n-source (+ ,n-offset 3))))))
  77.  
  78. ;;; Macros to handle the fact that we cannot use the machine native call and
  79. ;;; return instructions. 
  80.  
  81. (defmacro lisp-jump (function)
  82.   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  83.   `(progn
  84.      (inst j ,function (- (ash function-header-code-offset
  85.                    word-shift)
  86.               function-pointer-type))
  87.      (move code-tn ,function)))
  88.  
  89. (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
  90.   "Return to RETURN-PC."
  91.   `(progn
  92.      (inst j ,return-pc
  93.        (- (* (1+ ,offset) word-bytes) other-pointer-type))
  94.      ,(if frob-code
  95.       `(move code-tn ,return-pc)
  96.       '(inst nop))))
  97.  
  98. (defmacro emit-return-pc (label)
  99.   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
  100.   `(progn
  101.      (align lowtag-bits)
  102.      (emit-label ,label)
  103.      (inst lra-header-word)))
  104.  
  105.  
  106.  
  107. ;;;; Stack TN's
  108.  
  109. ;;; Load-Stack-TN, Store-Stack-TN  --  Interface
  110. ;;;
  111. ;;;    Move a stack TN to a register and vice-versa.
  112. ;;;
  113. (defmacro load-stack-tn (reg stack)
  114.   `(let ((reg ,reg)
  115.      (stack ,stack))
  116.      (let ((offset (tn-offset stack)))
  117.        (sc-case stack
  118.      ((control-stack)
  119.       (loadw reg cfp-tn offset))))))
  120.  
  121. (defmacro store-stack-tn (stack reg)
  122.   `(let ((stack ,stack)
  123.      (reg ,reg))
  124.      (let ((offset (tn-offset stack)))
  125.        (sc-case stack
  126.      ((control-stack)
  127.       (storew reg cfp-tn offset))))))
  128.  
  129.  
  130. ;;; MAYBE-LOAD-STACK-TN  --  Interface
  131. ;;;
  132. (defmacro maybe-load-stack-tn (reg reg-or-stack)
  133.   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
  134.   (once-only ((n-reg reg)
  135.           (n-stack reg-or-stack))
  136.     `(sc-case ,n-reg
  137.        ((any-reg descriptor-reg)
  138.     (sc-case ,n-stack
  139.       ((any-reg descriptor-reg)
  140.        (move ,n-reg ,n-stack))
  141.       ((control-stack)
  142.        (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
  143.  
  144.  
  145. ;;;; Storage allocation:
  146.  
  147. (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
  148.                  &body body)
  149.   "Do stuff to allocate an other-pointer object of fixed Size with a single
  150.   word header having the specified Type-Code.  The result is placed in
  151.   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
  152.   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
  153.   initializes the object."
  154.   `(pseudo-atomic (,temp-tn)
  155.      (inst add ,result-tn alloc-tn other-pointer-type)
  156.      (inst add alloc-tn alloc-tn (pad-data-block ,size))
  157.      (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
  158.      (storew ,temp-tn ,result-tn 0 other-pointer-type)
  159.      ,@body))
  160.  
  161.  
  162.  
  163. ;;;; Type testing noise.
  164.  
  165. ;;; GEN-RANGE-TEST -- internal
  166. ;;;
  167. ;;; Generate code that branches to TARGET iff REG contains one of VALUES.
  168. ;;; If NOT-P is true, invert the test.  Jumping to NOT-TARGET is the same
  169. ;;; as falling out the bottom.
  170. ;;; 
  171. (defun gen-range-test (reg target not-target not-p min seperation max values)
  172.   (let ((tests nil)
  173.     (start nil)
  174.     (end nil)
  175.     (insts nil))
  176.     (multiple-value-bind (equal less-or-equal greater-or-equal label)
  177.              (if not-p
  178.                  (values :ne :gt :lt not-target)
  179.                  (values :eq :le :ge target))
  180.       (flet ((emit-test ()
  181.            (if (= start end)
  182.            (push start tests)
  183.            (push (cons start end) tests))))
  184.     (dolist (value values)
  185.       (cond ((< value min)
  186.          (error "~S is less than the specified minimum of ~S"
  187.             value min))
  188.         ((> value max)
  189.          (error "~S is greater than the specified maximum of ~S"
  190.             value max))
  191.         ((not (zerop (rem (- value min) seperation)))
  192.          (error "~S isn't an even multiple of ~S from ~S"
  193.             value seperation min))
  194.         ((null start)
  195.          (setf start value))
  196.         ((> value (+ end seperation))
  197.          (emit-test)
  198.          (setf start value)))
  199.       (setf end value))
  200.     (emit-test))
  201.       (macrolet ((inst (name &rest args)
  202.                `(push (list 'inst ',name ,@args) insts)))
  203.     (do ((remaining (nreverse tests) (cdr remaining)))
  204.         ((null remaining))
  205.       (let ((test (car remaining))
  206.         (last (null (cdr remaining))))
  207.         (if (atom test)
  208.         (progn
  209.           (inst cmp reg test)
  210.           (if last
  211.               (inst b equal target)
  212.               (inst b :eq label)))
  213.         (let ((start (car test))
  214.               (end (cdr test)))
  215.           (cond ((and (= start min) (= end max))
  216.              (warn "The values ~S cover the entire range from ~
  217.              ~S to ~S [step ~S]."
  218.                    values min max seperation)
  219.              (push `(unless ,not-p (inst b ,target)) insts))
  220.             ((= start min)
  221.              (inst cmp reg end)
  222.              (if last
  223.                  (inst b less-or-equal target)
  224.                  (inst b :le label)))
  225.             ((= end max)
  226.              (inst cmp reg start)
  227.              (if last
  228.                  (inst b greater-or-equal target)
  229.                  (inst b :ge label)))
  230.             (t
  231.              (inst cmp reg start)
  232.              (inst b :lt (if not-p target not-target))
  233.              (inst cmp reg end)
  234.              (if last
  235.                  (inst b less-or-equal target)
  236.                  (inst b :le label))))))))))
  237.     (nreverse insts)))
  238.  
  239. (defun gen-other-immediate-test (reg target not-target not-p values)
  240.   (gen-range-test reg target not-target not-p
  241.           (+ other-immediate-0-type lowtag-limit)
  242.           (- other-immediate-1-type other-immediate-0-type)
  243.           (ash 1 type-bits)
  244.           values))
  245.  
  246.  
  247. (defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
  248.               function-p)
  249.   (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
  250.                (member odd-fixnum-type lowtags :test #'eql)))
  251.      (lowtags (sort (if fixnump
  252.                 (delete even-fixnum-type
  253.                     (remove odd-fixnum-type lowtags
  254.                         :test #'eql)
  255.                     :test #'eql)
  256.                 (copy-list lowtags))
  257.             #'<))
  258.      (lowtag (if function-p
  259.              vm:function-pointer-type
  260.              vm:other-pointer-type))
  261.      (hdrs (sort (copy-list hdrs) #'<))
  262.      (immed (sort (copy-list immed) #'<)))
  263.     (append
  264.      (when immed
  265.        `((inst and ,temp ,reg type-mask)
  266.      ,@(if (or fixnump lowtags hdrs)
  267.            (let ((fall-through (gensym)))
  268.          `((let (,fall-through (gen-label))
  269.              ,@(gen-other-immediate-test
  270.             temp (if not-p not-target target)
  271.             fall-through nil immed)
  272.              (emit-label ,fall-through))))
  273.            (gen-other-immediate-test temp target not-target not-p immed))))
  274.      (when fixnump
  275.        `((inst andcc zero-tn ,reg 3)
  276.      ,(if (or lowtags hdrs)
  277.           `(inst b :eq ,(if not-p not-target target))
  278.           `(inst b ,(if not-p :ne :eq) ,target))))
  279.      (when (or lowtags hdrs)
  280.        `((inst and ,temp ,reg lowtag-mask)))
  281.      (when lowtags
  282.        (if hdrs
  283.        (let ((fall-through (gensym)))
  284.          `((let ((,fall-through (gen-label)))
  285.          ,@(gen-range-test temp (if not-p not-target target)
  286.                    fall-through nil
  287.                    0 1 (1- lowtag-limit) lowtags)
  288.          (emit-label ,fall-through))))
  289.        (gen-range-test temp target not-target not-p 0 1
  290.                (1- lowtag-limit) lowtags)))
  291.      (when hdrs
  292.        `((inst cmp ,temp ,lowtag)
  293.      (inst b :ne ,(if not-p target not-target))
  294.      (inst nop)
  295.      (load-type ,temp ,reg (- ,lowtag))
  296.      ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
  297.  
  298. (defconstant immediate-types
  299.   (list base-char-type unbound-marker-type))
  300.  
  301. (defconstant function-subtypes
  302.   (list funcallable-instance-header-type closure-header-type
  303.     function-header-type closure-function-header-type))
  304.  
  305. (defmacro test-type (register temp target not-p &rest type-codes)
  306.   (let* ((type-codes (mapcar #'eval type-codes))
  307.      (lowtags (remove lowtag-limit type-codes :test #'<))
  308.      (extended (remove lowtag-limit type-codes :test #'>))
  309.      (immediates (intersection extended immediate-types :test #'eql))
  310.      (headers (set-difference extended immediate-types :test #'eql))
  311.      (function-p nil))
  312.     (unless type-codes
  313.       (error "Must supply at least on type for test-type."))
  314.     (when (and headers (member other-pointer-type lowtags))
  315.       (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
  316.       (setf headers nil))
  317.     (when (and immediates
  318.            (or (member other-immediate-0-type lowtags)
  319.            (member other-immediate-1-type lowtags)))
  320.       (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
  321.       (setf immediates nil))
  322.     (when (intersection headers function-subtypes)
  323.       (unless (subsetp headers function-subtypes)
  324.     (error "Can't test for mix of function subtypes and normal ~
  325.         header types."))
  326.       (setq function-p t))
  327.       
  328.     (let ((n-reg (gensym))
  329.       (n-temp (gensym))
  330.       (n-target (gensym))
  331.       (not-target (gensym)))
  332.       `(let ((,n-reg ,register)
  333.          (,n-temp ,temp)
  334.          (,n-target ,target)
  335.          (,not-target (gen-label)))
  336.      (declare (ignorable ,n-temp))
  337.      ,@(if (constantp not-p)
  338.            (test-type-aux n-reg n-temp n-target not-target
  339.                   (eval not-p) lowtags immediates headers
  340.                   function-p)
  341.            `((cond (,not-p
  342.             ,@(test-type-aux n-reg n-temp n-target not-target t
  343.                      lowtags immediates headers
  344.                      function-p))
  345.                (t
  346.             ,@(test-type-aux n-reg n-temp n-target not-target nil
  347.                      lowtags immediates headers
  348.                      function-p)))))
  349.      (inst nop)
  350.      (emit-label ,not-target)))))
  351.  
  352.  
  353. ;;;; Error Code
  354.  
  355. (defvar *adjustable-vectors* nil)
  356.  
  357. (defmacro with-adjustable-vector ((var) &rest body)
  358.   `(let ((,var (or (pop *adjustable-vectors*)
  359.            (make-array 16
  360.                    :element-type '(unsigned-byte 8)
  361.                    :fill-pointer 0
  362.                    :adjustable t))))
  363.      (setf (fill-pointer ,var) 0)
  364.      (unwind-protect
  365.      (progn
  366.        ,@body)
  367.        (push ,var *adjustable-vectors*))))
  368.  
  369. (eval-when (compile load eval)
  370.   (defun emit-error-break (vop kind code values)
  371.     (let ((vector (gensym)))
  372.       `((let ((vop ,vop))
  373.       (when vop
  374.         (note-this-location vop :internal-error)))
  375.     (inst unimp ,kind)
  376.     (with-adjustable-vector (,vector)
  377.       (write-var-integer (error-number-or-lose ',code) ,vector)
  378.       ,@(mapcar #'(lambda (tn)
  379.             `(let ((tn ,tn))
  380.                (write-var-integer (make-sc-offset (sc-number
  381.                                    (tn-sc tn))
  382.                                   (tn-offset tn))
  383.                           ,vector)))
  384.             values)
  385.       (inst byte (length ,vector))
  386.       (dotimes (i (length ,vector))
  387.         (inst byte (aref ,vector i))))
  388.     (align word-shift)))))
  389.  
  390. (defmacro error-call (vop error-code &rest values)
  391.   "Cause an error.  ERROR-CODE is the error to cause."
  392.   (cons 'progn
  393.     (emit-error-break vop error-trap error-code values)))
  394.  
  395.  
  396. (defmacro cerror-call (vop label error-code &rest values)
  397.   "Cause a continuable error.  If the error is continued, execution resumes at
  398.   LABEL."
  399.   `(progn
  400.      (inst b ,label)
  401.      ,@(emit-error-break vop cerror-trap error-code values)))
  402.  
  403. (defmacro generate-error-code (vop error-code &rest values)
  404.   "Generate-Error-Code Error-code Value*
  405.   Emit code for an error with the specified Error-Code and context Values."
  406.   `(assemble (*elsewhere*)
  407.      (let ((start-lab (gen-label)))
  408.        (emit-label start-lab)
  409.        (error-call ,vop ,error-code ,@values)
  410.        start-lab)))
  411.  
  412. (defmacro generate-cerror-code (vop error-code &rest values)
  413.   "Generate-CError-Code Error-code Value*
  414.   Emit code for a continuable error with the specified Error-Code and
  415.   context Values.  If the error is continued, execution resumes after
  416.   the GENERATE-CERROR-CODE form."
  417.   (let ((continue (gensym "CONTINUE-LABEL-"))
  418.     (error (gensym "ERROR-LABEL-")))
  419.     `(let ((,continue (gen-label)))
  420.        (emit-label ,continue)
  421.        (assemble (*elsewhere*)
  422.      (let ((,error (gen-label)))
  423.        (emit-label ,error)
  424.        (cerror-call ,vop ,continue ,error-code ,@values)
  425.        ,error)))))
  426.  
  427.  
  428.  
  429. ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
  430. ;;;
  431. (defmacro pseudo-atomic ((ndescr-temp) &rest forms)
  432.   (let ((label (gensym "LABEL-")))
  433.     `(let ((,label (gen-label)))
  434.        (store-symbol-value zero-tn lisp::*pseudo-atomic-interrupted*)
  435.        ;; Note: we just use cfp as some not-zero value.
  436.        (store-symbol-value cfp-tn lisp::*pseudo-atomic-atomic*)
  437.        ,@forms
  438.        (store-symbol-value zero-tn lisp::*pseudo-atomic-atomic*)
  439.        (load-symbol-value ,ndescr-temp lisp::*pseudo-atomic-interrupted*)
  440.        (inst cmp ,ndescr-temp)
  441.        (inst b :eq ,label)
  442.        (inst nop)
  443.        (inst unimp pending-interrupt-trap)
  444.        (emit-label ,label))))
  445.  
  446.  
  447.  
  448.